perm filename TRUNC.F4[SCR,LCS] blob sn#369213 filedate 1978-07-26 generic text, type T, neo UTF8
	SUBROUTINE TRUNC
	DIMENSION PX(2496),PXL(2496)
C  96*27=2592  STARTS WITH PARAM #4 → 99.
	COMMON INUM,L,CNT(1) /COPY/NUMP,COPY(1) /COPYL/COPYL(1)
	1 /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,BY,
	1 K,NPAR,N,TBG,AC,NPA
	IF(INUM.NE.1)GO TO 5
	L=0
	CALL TRUNCX(COPY,COPYL)
	RETURN 
5	L=(INUM-2)*96-3
	IF(CNT(INUM).GT.1)GO TO 3
C INIT THE LIST.
	DO 4 K=4,NPA
4	PX(K+L)='$'
3 	CALL TRUNCX(PX,PXL)
	END

	SUBROUTINE TRUNCX(PX,PXL)
	DIMENSION PX(1),PXL(1)
C  96*27=2592  STARTS WITH PARAM #4 → 99.
	COMMON INUM,L,CNT(1) /P/P(1) /PL/PL(1)
	1 /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,BY,
	1 K,NPAR,N,TBG,AC,NPA
	
	NPX=0
	DO 1 K=NPA,4,-1
	N=K+L
	X=PL(K)
	IF(P(K).NE.PX(N))GO TO 2
	IF(X.GT.2)GO TO 2
	IF(X.EQ.PXL(N))GO TO 1
2	IF(NPX.EQ.0)NPX=K
	PX(N)=P(K)
	PXL(N)=X
1	CONTINUE
	NPA=3
	IF(NPX.NE.0)NPA=NPX
	END